:- import "%%/meta/commons.sl" #
:- import "%%/lib/data.sl" #
:- import "%%/lib/list.sl" #


filter.program .program0 .program1 :-
	filterTransitive .program0 .program,
	transform.clauses .program:.program1 .cl0:.cl1 (
		filterClause .cl0 .cl1
	) #

filterClause .cl0 .cl1 :-
	filterFuncInClause .cl0:.cl,
	(filterLoop .cl:.cl1; .cl = .cl1) #


-- Transitive Variables --

filterTransitive (.head :- .clause) (.head1 :- .clause1) :-
	transform.leaves .head:.head1 .tr:.expanded (
		declareTransitive .trans .tr .expanded
	),
	openList.terminate .trans
	,
	transform.leaves .clause:.clause1 .tr:.expanded (
		getTransitive .trans .tr .expanded
	)
	,
	bindLast .trans ! #

declareTransitive .trans .name .t0:.t1 :-
	is.transitive .name,
	list.member .trans (.name .t0:.t1 (.t0, .)) ! #

getTransitive .trans .name .t0:.t1 :-
	is.transitive .name,
	list.member .trans (.name . .list) !
	openList.tail .list .t0,
	openList.append .list (.t1,) #

	-- Binds the last variable appearance to its result
bindLast $ #
bindLast (. .:.last .list, .remains) :-
	openList.tail .list .last, bindLast .remains #


-- Function Calls --

	-- Converts (write (length .v ^)) into (length .v .xx, write .xx)
filterFuncInClause .cl0:.cl1 :-
	transform.recursive .cl0:.cl .arg0:.arg1 (
		(filterFuncInNode .cl1) .arg0:.arg1
	),
	openList.extend .cl1 .cl #

(filterFuncInNode .calls) .arg0:.arg1 :-
	.arg0 = .callL ^ .callR,
	forceTuple .tupleL .callL, length .tupleL .lenL,
	forceTuple .tupleR .callR, length .tupleR .lenR,
	let .lenL1 (.lenL + 1), let .len1 (.lenL1 + .lenR),
	length .call1 .len1,
	mnth .call1 0 .lenL .tupleL,
	nth .call1 .lenL .arg1,
	mnth .call1 .lenL1 0 .tupleR,
	openList.append .calls (.call1,) #

	-- Forces a tuple to contain something
forceTuple .tuple .tuple :- is.tuple .tuple ! #
forceTuple [] $ :- ! #
forceTuple [.o] .o #


-- Loop Constructs --

filterLoop (.spec => .goal):.call :-
	conditions .spec .begin .beginPred .end .endPred .step0:.step1 .stepPred,
	temporary LOOP .s, parse .s .tag,
	.call = (.beginPred, .tag .begin),
	assert (.tag .end :- .endPred !),
	assert (.tag .step0 :- .stepPred, .goal ! .tag .step1) #

conditions (.spec | .remains) -- Parallel conditions
	.bc (.bp, .bp1) .ec (.ep, .ep1) .sc:.tc (.sp, .sp1) :- !
	conditions .spec .b .bp .e .ep .s0:.s1 .sp,
	conditions .remains .b1 .bp1 .e1 .ep1 .t0:.t1 .sp1,
	tuple.concat .b .b1 .bc,
	tuple.concat .e .e1 .ec,
	tuple.concat .s0 .t0 .sc,
	tuple.concat .s1 .t1 .tc #
conditions (for .elem of .list)
	[.list] $
	[$] $
	[.elem, .remains]:[.remains] $ :- ! #
conditions (for .elem in .t)
	[0 .len .t] (length .t .len)
	[.i .i .] $
	[.i .len .t]:[.i1 .len .t] (nth .t .i .elem, let .i1 (.i + 1)) :- ! #
conditions (for .i .a .b)
	[.a .b] $
	[.b .b] $
	[.i .b]:[.i1 .b] (let .i1 (.i + 1)) :- ! #
conditions (out .v) [.v] $ [.v] $ [.v] $ :- ! #
conditions (pass .v0:.v1 .s0:.s1)
	[.v0 .v1] $ [.v1 .v1] $ [.s0 .v1]:[.s1 .v1] $ #


-- Undefined Predicate --

checkUndefined :-
	findall.unordered .call (
		rule .rule,
		rule.callSign .rule .call
	) .calls,
	forall (rule .rule) (
		checkUndefinedCalls .rule .calls
	) #

checkUndefinedCalls .rule .userCalls :-
	rule.headTail .rule . .tail,
	findall.unordered .call (
		traverse.clauses .tail .pred,
		rule.callSign .pred .call
	) .calls
	,
	forall (list.member .calls .call) (
		.call = .name / .n, (
			is.variable .name;
			infix .name . . ., .n = 1
		);
		systemCall .call;
		list.member .userCalls .call;
		concat .call .callStr,
		checkWarning .rule ("calls undefined predicate:" .callStr)
	) #


-- Singleton Variable --

checkSingleton .rule :-
	findVariables .rule .vars,
	checkTwoOccs .vars .varsInfo,
	openList.terminate .varsInfo,
	forall (list.member .varsInfo (.var (. .2ndOcc))) (
		if (free .2ndOcc) then (
			checkWarning .rule ("has singleton variable:" .var)
		)
	) ! #

findVariables .rule .vars :-
	findall.unordered .var (
		traverse .rule .var,
		is.variable .var,
		not (length .var 1)
	) .vars #

checkTwoOccs $ . #
checkTwoOccs (.var, .remains) .varsInfo :-
	once (list.member .varsInfo (.var .v)),
	.v = .1stOcc .2ndOcc,
	if (free .1stOcc) then (.1stOcc = Y) else (.2ndOcc = Y),
	checkTwoOccs .remains .varsInfo #


-- Helpers --

checkWarning .rule .msg :-
	get IMPORTING .file,
	stream.createBuffer BUFFER,
	stream.dump BUFFER .rule,
	stream.line BUFFER .ruleDump,
	stream.close BUFFER,
	write "[WARNING]" .file .ruleDump .msg,
	nl, nl #
